home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / assert.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  8KB  |  202 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    assert.lsp
  6.  
  7.  
  8. (in-package 'lisp)
  9.  
  10.  
  11. (export '(check-type assert
  12.           ecase ccase typecase etypecase ctypecase))
  13.  
  14.  
  15. (in-package 'system)
  16.  
  17.  
  18. (proclaim '(optimize (safety 2) (space 3)))
  19.  
  20.  
  21. (defmacro check-type (place typespec &optional (string nil s))
  22.   `(do ((*print-level* 4)
  23.         (*print-length* 4))
  24.        ((typep ,place ',typespec) nil)
  25.        (cerror ""
  26.                "The value of ~:@(~S~), ~:@(~S~), is not ~A."
  27.                ',place ,place
  28.                ,(if s string `',typespec))
  29.        ,(ask-for-form place)
  30.        (format *error-output* "Now continuing ...~%")))
  31.  
  32.  
  33. (defmacro assert (test-form &optional places string &rest args)
  34.   `(do ((*print-level* 4)
  35.         (*print-length* 4))
  36.        (,test-form nil)
  37.        ,(if string
  38.             `(cerror "" ,string ,@args)
  39.             `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form))
  40.        ,@(mapcar #'ask-for-form places)
  41.        (format *error-output* "Now continuing ...~%")))
  42.  
  43.  
  44. (defun ask-for-form (place)
  45.   `(progn (format  *error-output*
  46.                    "Please input the new value for the place ~:@(~S~): "
  47.                    ',place)
  48.           (finish-output *error-output*)
  49.           (setf ,place (read))))
  50.  
  51.  
  52. (defmacro ecase (keyform &rest clauses &aux (key (gensym)))
  53.    (do ((l (reverse clauses) (cdr l))
  54.         (form `(let ((*print-level* 4)
  55.                      (*print-length* 4))
  56.                  (error
  57.                   "The value of ~:@(~S~), ~:@(~S~), is ~
  58.                   ~#[nonsense~;not ~:@(~S~)~;neither ~:@(~S~) nor ~:@(~S~)~
  59.                   ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
  60.                   ',keyform
  61.                   ,key
  62.                   ,@(mapcan #'(lambda (x)
  63.                                 (if (listp (car x))
  64.                                     (mapcar #'(lambda (y) `',y) (car x))
  65.                                     `(',(car x))))
  66.                             clauses)))))
  67.        ((endp l) `(let ((,key ,keyform)) ,form))
  68.        (when (caar l)
  69.              (setq form `(if ,(if (listp (caar l))
  70.                                   `(member ,key ',(caar l))
  71.                                   `(eql ,key ',(caar l)))
  72.                              (progn ,@(cdar l))
  73.                              ,form))))
  74. )
  75.  
  76. (defmacro ccase (keyplace &rest clauses &aux (key (gensym)))
  77.    `(loop (let ((,key ,keyplace))
  78.                ,@(mapcar #'(lambda (l)
  79.                                   `(when ,(if (listp (car l))
  80.                                               `(member ,key ',(car l))
  81.                                               `(eql ,key ',(car l)))
  82.                                          (return (progn ,@(cdr l)))))
  83.                          clauses)
  84.                (let ((*print-level* 4)
  85.                      (*print-length* 4))
  86.                     (cerror ""
  87.                             "The value of ~:@(~S~), ~:@(~S~), is ~
  88.                              ~#[nonsense~;not ~:@(~S~)~;neither ~
  89.                              ~:@(~S~) nor ~:@(~S~)~
  90.                              ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
  91.                              ',keyplace
  92.                              ,key
  93.                              ,@(mapcan
  94.                                 #'(lambda (x)
  95.                                          (if (listp (car x))
  96.                                              (mapcar #'(lambda (y) `',y)
  97.                                                      (car x))
  98.                                              `(',(car x))))
  99.                                 clauses))
  100.                     ,(ask-for-form keyplace)
  101.                     (format *error-output* "Now continuing ...~%"))))
  102.    )
  103.  
  104. (defmacro typecase (keyform &rest clauses)
  105.   (do ((l (reverse clauses) (cdr l))
  106.        (form nil) (key (gensym)))
  107.       ((endp l) `(let ((,key ,keyform)) ,form))
  108.       (if (or (eq (caar l) 't) (eq (caar l) 'otherwise))
  109.           (setq form `(progn ,@(cdar l)))
  110.           (setq form
  111.                 `(if (typep ,key (quote ,(caar l)))
  112.                      (progn ,@(cdar l))
  113.                      ,form))))
  114.   )
  115.  
  116. (defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
  117.    (do ((l clauses (cdr l))
  118.         (form `(error (typecase-error-string
  119.                        ',keyform ,key
  120.                        ',(mapcar #'(lambda (l) (car l)) clauses)))))
  121.        ((endp l) `(let ((,key ,keyform)) ,form))
  122.        (setq form `(if (typep ,key ',(caar l))
  123.                        (progn ,@(cdar l))
  124.                        ,form))
  125.        )
  126.    )
  127.  
  128. (defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
  129.   `(loop (let ((,key ,keyplace))
  130.               ,@(mapcar #'(lambda (l)
  131.                                  `(when (typep ,key ',(car l))
  132.                                         (return (progn ,@(cdr l)))))
  133.                         clauses)
  134.               (cerror ""
  135.                       (typecase-error-string
  136.                        ',keyplace ,key
  137.                        ',(mapcar #'(lambda (l) (car l)) clauses))))
  138.          ,(ask-for-form keyplace)
  139.          (format *error-output* "Now continuing ...~%")))
  140.   )
  141.  
  142. (defun typecase-error-string
  143.        (keyform keyvalue negs
  144.                 &aux (negs1 nil) (poss nil) (poss1 nil))
  145.    (do ()
  146.        ((endp negs))
  147.        (if (symbolp (car negs))
  148.            (progn (push (list (car negs)) negs1) (pop negs))
  149.            (case (caar negs)
  150.                  (or (setq negs (append (cdar negs) (cdr negs))))
  151.                  (member (mapc #'(lambda (x) (push `(member ,x) negs1))
  152.                                (cdar negs))
  153.                          (pop negs))
  154.                  (not (push (cadar negs) poss) (pop negs))
  155.                  (otherwise (push (car negs) negs1) (pop negs)))))
  156.    (do ()
  157.        ((endp poss))
  158.        (cond ((symbolp (car poss)) (push (list (car poss)) poss1) (pop poss))
  159.              ((eq (caar poss) 'and)
  160.               (setq poss (append (cdar poss) (cdr poss))))
  161.              (t (push (car poss) poss1) (pop poss))))
  162.    (format
  163.     nil
  164.     "The value of ~:@(~S~), ~:@(~S~), is ~?~?."
  165.     keyform
  166.     keyvalue
  167.     "~#[~;~;~?~;~;~? and ~?~:;~%~@{~#[~;~;and ~]~?~^, ~}~]"
  168.     (mapcan 'typecase-error-strings poss1)
  169.     "~:[~[something~;~:;~%~]~;~[~:;, but~%~]~]~
  170.      ~#[~;~;not ~?~;~;neither ~? nor ~?~:;not ~@{~#[~;~;or ~]~?~^, ~}~]"
  171.     (cons poss1 (cons (length negs1)
  172.                       (mapcan 'typecase-error-strings (reverse negs1))))
  173.     )
  174.    )
  175.  
  176. (defun typecase-error-strings (type)
  177.  (cond ((eq (car type) 'member)
  178.         (case (length (cdr type))
  179.               (0 `("one of none" nil))
  180.               (1 `("~:@(~S~)" (,(cadr type))))
  181.               (2 `("either ~:@(~S~) or ~:@(~S~)" ,(cdr type)))
  182.               (t `("one of ~:@(~S~)" (,(cdr type))))))
  183.        ((eq (car type) 'satisfies)
  184.         `("an object satisfying ~:@(~S~)" ,(cdr type)))
  185.        ((or (endp (cdr type)) (null (remove '* (cdr type))))
  186.         (let ((x (assoc (car type)
  187.                         '((t "anything")
  188.                           (nil "none")
  189.                           (null "nil")
  190.                           (common "an object of a standard data type")))))
  191.              (if x
  192.                  `(,(cadr x) nil)
  193.                  `("~:[a~;an~] ~(~A~)" (,(boin-p (car type)) ,(car type))))))
  194.        (t `("~:[a~;an~] ~:@(~S~)" (,(boin-p (car type)) ,type))))
  195.  )
  196.  
  197. (defun boin-p (symbol)
  198.        (member (elt (symbol-name symbol) 0)
  199.                '(#\A #\I #\U #\E #\O #\a #\i #\u #\e #\o))
  200. )
  201.  
  202.